home *** CD-ROM | disk | FTP | other *** search
/ PC Answers 1995 May / PC Answers CD-ROM 7 (Future Publishing) (May 1995).iso / vbits / code / mee / vbdao / visdata / vbimex.bas < prev    next >
Encoding:
BASIC Source File  |  1994-10-06  |  9.1 KB  |  344 lines
  1. 'global vars
  2. Global gDataType As Integer
  3. Global gDB As Database
  4. Global gImpDB As Database
  5. Global gExpDB As Database
  6. 'Global gstDBName As String
  7. Global gExpTable As String
  8.  
  9. 'data types
  10. Global Const DT_NONE = -1
  11. Global Const DT_MSACCESS = 0
  12. Global Const DT_PARADOX = 1
  13. Global Const DT_FOXPRO25 = 2
  14. Global Const DT_FOXPRO20 = 3
  15. Global Const DT_DBASEIV = 4
  16. Global Const DT_DBASEIII = 5
  17. Global Const DT_BTRIEVE = 6
  18. Global Const DT_SQLDB = 7
  19. Global Const DT_TABDELIM = 8
  20.  
  21. Function DupeTableName (tname As String) As Integer
  22.   For i = 0 To fTables.cTableList.ListCount - 1
  23.     If UCase(fTables.cTableList.List(i)) = UCase(tname) Then
  24.       DupeTableName = True
  25.       Exit Function
  26.     End If
  27.   Next
  28.   DupeTableName = False
  29. End Function
  30.  
  31. Sub Export (tbl As String, todb As String)
  32.  
  33.   On Error GoTo ExpErr
  34.  
  35.   Dim Connect As String, newtbl As String
  36.   Dim errstate As Integer
  37.   Dim idx As Index
  38.   Dim ss As String               'local copy of sql string
  39.   Dim fs As String, fr As String 'field and from string for SQL
  40.  
  41.   If gDataType = DT_SQLDB Then
  42.     Set gExpDB = OpenDatabase("", 0, 0, "odbc;")
  43.     If gExpDB Is Nothing Then Exit Sub
  44.   End If
  45.  
  46.   SetHourglass VDMDI
  47.   MsgBar "Exporting '" & tbl & "'", True
  48.  
  49.   errstate = 1
  50.   Select Case gDataType
  51.     Case DT_MSACCESS
  52.       Connect = "[;database=" & todb & "]."
  53.       Set gExpDB = OpenDatabase(todb)
  54.     Case DT_PARADOX
  55.       Connect = "[Paradox 3.X;database=" & IMEXStripFileName(todb) & "]."
  56.       Set gExpDB = OpenDatabase(todb, 0, 0, "Paradox 3.X")
  57.     Case DT_FOXPRO25
  58.       Connect = "[FoxPro 2.5;database=" & IMEXStripFileName(todb) & "]."
  59.       Set gExpDB = OpenDatabase(todb, 0, 0, "FoxPro 2.5")
  60.     Case DT_FOXPRO20
  61.       Connect = "[FoxPro 2.0;database=" & IMEXStripFileName(todb) & "]."
  62.       Set gExpDB = OpenDatabase(todb, 0, 0, "FoxPro 2.0")
  63.     Case DT_DBASEIV
  64.       Connect = "[dBase IV;database=" & IMEXStripFileName(todb) & "]."
  65.       Set gExpDB = OpenDatabase(todb, 0, 0, "dBase IV")
  66.     Case DT_DBASEIII
  67.       Connect = "[dBase III;database=" & IMEXStripFileName(todb) & "]."
  68.       Set gExpDB = OpenDatabase(todb, 0, 0, "dBase III")
  69.     Case DT_BTRIEVE
  70.       Connect = "[Btrieve;database=" & todb & "]."
  71.       Set gExpDB = OpenDatabase(todb, 0, 0, "Btrieve")
  72.     Case DT_SQLDB
  73.       Connect = "[" & gExpDB.Connect & "]."
  74.   End Select
  75.   If gDataType = DT_MSACCESS Or gDataType = DT_BTRIEVE Or gDataType = DT_SQLDB Then
  76.     ExpName.Label1 = "Export " & tbl & " to:"
  77.     ExpName.Label2 = "in " & todb
  78.     ExpName.cTable = tbl
  79.     ExpName.Show MODAL
  80.     If Len(gExpTable) = 0 Then
  81.       ResetMouse VBIMEX
  82.       MsgBar "", False
  83.       Exit Sub
  84.     Else
  85.       newtbl = gExpTable
  86.     End If
  87.   Else
  88.     newtbl = tbl
  89.   End If
  90.   MsgBar "Exporting '" & newtbl & "'", True
  91.   If Len(tbl) > 0 Then
  92.     gDB.Execute "select * into " & Connect & StripOwner(newtbl) & " from " & StripOwner(tbl)
  93.  
  94.     errstate = 2
  95.     MsgBar "Creating Indexes for '" & newtbl & "'", True
  96.     gExpDB.TableDefs.Refresh
  97.     For i = 0 To gDB.TableDefs(tbl).Indexes.Count - 1
  98.       Set idx = New Index
  99.       idx.Name = gDB.TableDefs(tbl).Indexes(i).Name
  100.       idx.Fields = gDB.TableDefs(tbl).Indexes(i).Fields
  101.       idx.Unique = gDB.TableDefs(tbl).Indexes(i).Unique
  102.       If gDataType <> DT_SQLDB And gstDataType <> "ODBC" Then
  103.         idx.Primary = gDB.TableDefs(tbl).Indexes(i).Primary
  104.       End If
  105.       gExpDB.TableDefs(tbl).Indexes.Append idx
  106.     Next
  107.     ResetMouse VBIMEX
  108.     MsgBar "", False
  109.     MsgBox "Successfully Exported '" & tbl & "'.", 64
  110.   Else
  111.     ss = fSQL.cSQLStatement
  112.     fs = Mid(ss, 8, InStr(8, UCase(ss), "FROM") - 9)
  113.     fr = " " & Mid(ss, InStr(UCase(ss), "FROM"), Len(ss))
  114.     gDB.Execute "select " & fs & " into " & Connect & newtbl & fr
  115.  
  116.     ResetMouse VBIMEX
  117.     MsgBar "", False
  118.     MsgBox "Successfully Exported SQL Statement.", 64
  119.     
  120.   End If
  121.  
  122.  
  123.   Exit Sub
  124.  
  125. JetErr:
  126.   MsgBox "Error " & x & " code returned!"
  127.   ResetMouse VBIMEX
  128.   MsgBar "", False
  129.   Exit Sub
  130.  
  131. ExpErr:
  132.   If Err = 3010 Then      'table exists
  133.     If MsgBox("'" & tbl & "' already exists - overwrite?", 32 + 1 + 256) = 1 Then
  134.       gExpDB.TableDefs.Delete tbl
  135.       Resume
  136.     Else
  137.       ResetMouse VBIMEX
  138.       MsgBar "", False
  139.       Exit Sub
  140.     End If
  141.   End If
  142.  
  143.   'nuke the new table if the indexes couldn't be created
  144.   If errstate = 2 Then
  145.     gExpDB.TableDefs.Delete tbl
  146.   End If
  147.   ResetMouse VBIMEX
  148.   ShowError
  149.   MsgBar "", False
  150.   Exit Sub
  151.  
  152. End Sub
  153.  
  154. Sub ExportTabDelim (tbl As String, todb As String)
  155.   Dim ds As Dynaset
  156.   Dim l As Long
  157.   Dim i As Integer
  158.   Dim st As String
  159.  
  160.   On Error GoTo ExportErr
  161.  
  162.   SetHourglass VBIMEX
  163.   MsgBar "Exporting Data to " & todb, True
  164.  
  165.   If Len(tbl) > 0 Then
  166.     Set ds = gCurrentDB.CreateDynaset(tbl)
  167.   Else
  168.     Set ds = gCurrentDB.CreateDynaset(fSQL.cSQLStatement)
  169.   End If
  170.  
  171.   Open todb For Output As #1
  172.  
  173.   'output the field names
  174.   st = Chr$(9)
  175.   For i = 0 To ds.Fields.Count - 1
  176.     st = st + ds(i).Name + Chr$(9)
  177.   Next
  178.   Print #1, st
  179.  
  180.   'output the field contents
  181.   l = 1
  182.   While ds.EOF = False
  183.     st = CStr(l) + Chr$(9)
  184.     For i = 0 To ds.Fields.Count - 1
  185.       st = st + vFieldVal((ds(i))) + Chr$(9)
  186.     Next
  187.     Print #1, st
  188.     ds.MoveNext
  189.     l = l + 1
  190.   Wend
  191.  
  192.   GoTo ExportEnd
  193.  
  194. ExportErr:
  195.   ShowError
  196.   Resume ExportEnd
  197.  
  198. ExportEnd:
  199.   Close #1
  200.   ResetMouse VBIMEX
  201.   MsgBar NULL_STR, False
  202.  
  203. End Sub
  204.  
  205. Sub IMEXRefreshTables ()
  206.  
  207.   VBIMEX.cTables.Clear
  208.   For i = 0 To gDB.TableDefs.Count - 1
  209.     If (gDB.TableDefs(i).Attributes And DB_SYSTEMOBJECT) = 0 Then
  210.       VBIMEX.cTables.AddItem gDB.TableDefs(i).Name
  211.     End If
  212.   Next
  213.   VBIMEX.cTables.ListIndex = 0
  214.    
  215. End Sub
  216.  
  217. Function IMEXStripFileName (fname As String) As String
  218.   On Error Resume Next
  219.   Dim i As Integer
  220.  
  221.   For i = Len(fname) To 1 Step -1
  222.     If Mid(fname, i, 1) = "\" Then
  223.       Exit For
  224.     End If
  225.   Next
  226.  
  227.   IMEXStripFileName = Mid(fname, 1, i - 1)
  228.  
  229. End Function
  230.  
  231. Sub Import (tbl As String)
  232.   On Error GoTo ImpErr
  233.  
  234.   Dim oldtbl As String, newtbl As String, Connect As String
  235.   Dim idx As Index
  236.   Dim errstate As Integer
  237.  
  238.   oldtbl = MakeTableName(tbl, False)
  239.   newtbl = MakeTableName(tbl, True)
  240.  
  241.   SetHourglass VDMDI
  242.   MsgBar "Importing '" & newtbl & "'", True
  243.  
  244.   errstate = 1
  245.   Select Case gDataType
  246.     Case DT_MSACCESS
  247.       Connect = "[;database=" & gImpDB.Name & "]."
  248.     Case DT_PARADOX
  249.       Connect = "[Paradox 3.X;database=" & IMEXStripFileName(tbl) & "]."
  250.       Set gImpDB = OpenDatabase(IMEXStripFileName(tbl), 0, 0, "Paradox 3.X")
  251.     Case DT_FOXPRO25
  252.       Connect = "[FoxPro 2.5;database=" & IMEXStripFileName(tbl) & "]."
  253.       Set gImpDB = OpenDatabase(IMEXStripFileName(tbl), 0, 0, "FoxPro 2.5")
  254.     Case DT_FOXPRO20
  255.       Connect = "[FoxPro 2.0;database=" & IMEXStripFileName(tbl) & "]."
  256.       Set gImpDB = OpenDatabase(IMEXStripFileName(tbl), 0, 0, "FoxPro 2.0")
  257.     Case DT_DBASEIV
  258.       Connect = "[dBase IV;database=" & IMEXStripFileName(tbl) & "]."
  259.       Set gImpDB = OpenDatabase(IMEXStripFileName(tbl), 0, 0, "dBase IV")
  260.     Case DT_DBASEIII
  261.       Connect = "[dBase III;database=" & IMEXStripFileName(tbl) & "]."
  262.       Set gImpDB = OpenDatabase(IMEXStripFileName(tbl), 0, 0, "dBase III")
  263.     Case DT_BTRIEVE
  264.       Connect = "[Btrieve;database=" & gImpDB.Name & "]."
  265.     Case DT_SQLDB
  266.       Connect = "[" & gImpDB.Connect & "]."
  267.   End Select
  268.   gDB.Execute "select * into " & newtbl & " from " & Connect & oldtbl
  269.  
  270.   errstate = 2
  271.   MsgBar "Creating Indexes for '" & newtbl & "'", True
  272.   gDB.TableDefs.Refresh
  273.   For i = 0 To gImpDB.TableDefs(oldtbl).Indexes.Count - 1
  274.     Set idx = New Index
  275.     idx.Name = gImpDB.TableDefs(oldtbl).Indexes(i).Name
  276.     idx.Fields = gImpDB.TableDefs(oldtbl).Indexes(i).Fields
  277.     idx.Unique = gImpDB.TableDefs(oldtbl).Indexes(i).Unique
  278.     If gDataType <> DT_SQLDB Then
  279.       idx.Primary = gImpDB.TableDefs(oldtbl).Indexes(i).Primary
  280.     End If
  281.     gDB.TableDefs(newtbl).Indexes.Append idx
  282.   Next
  283.  
  284.   VBIMEX.cTables.AddItem newtbl
  285.   fTables.cTableList.AddItem newtbl
  286.   ResetMouse VBIMEX
  287.   MsgBar "", False
  288.   MsgBox "Successfully Imported '" & newtbl & "'.", 64
  289.  
  290.   Exit Sub
  291.  
  292. ImpErr:
  293.   'nuke the new table if the indexes couldn't be created
  294.   If errstate = 2 Then
  295.     gDB.TableDefs.Delete newtbl
  296.   End If
  297.   ResetMouse VBIMEX
  298.   ShowError
  299.   MsgBar "", False
  300.   Exit Sub
  301.  
  302. End Sub
  303.  
  304. Function MakeTableName (fname As String, newname As Integer) As String
  305.   On Error Resume Next
  306.   Dim i As Integer, t As Integer
  307.   Dim tmp As String
  308.  
  309.   If gDataType = DT_SQLDB And newname Then
  310.     i = InStr(1, fname, ".")
  311.     If i > 0 Then
  312.       tmp = Mid(fname, 1, i - 1) & "_" & Mid(fname, i + 1, Len(fname))
  313.     End If
  314.   ElseIf InStr(fname, "\") > 0 Then
  315.     'strip off path
  316.     For i = Len(fname) To 1 Step -1
  317.       If Mid(fname, i, 1) = "\" Then
  318.         Exit For
  319.       End If
  320.     Next
  321.     tmp = Mid(fname, i + 1, Len(fname))
  322.     i = InStr(1, tmp, ".")
  323.     If i > 0 Then
  324.       tmp = Mid(tmp, 1, i - 1)
  325.     End If
  326.   Else
  327.     tmp = fname
  328.   End If
  329.  
  330.   If newname Then
  331.     If DupeTableName(tmp) Then
  332.       t = 1
  333.       While DupeTableName(tmp + CStr(t))
  334.         t = t + 1
  335.       Wend
  336.       tmp = tmp + CStr(t)
  337.     End If
  338.   End If
  339.  
  340.   MakeTableName = tmp
  341.  
  342. End Function
  343.  
  344.